home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.03 Mar 89 / Forth Source Code / Extsub.fth < prev    next >
Encoding:
Text File  |  1989-01-16  |  6.9 KB  |  307 lines  |  [TEXT/MACH]
  1. \ external code resource linker
  2. \ to be used for linking in external subroutines
  3. \ syntax
  4. \ : <forth word>
  5. \    [ ExtProc 3 mySub ] ( gets resource PROC "mySub" and links it in )
  6. \           ( 3 parameters required )
  7. \    [ ExtFunc 3 myFnc ] ( gets resource FUNC "myFnc" and links it in )
  8. \           ( 3 parameters required, placeholder for function result )
  9. \ ;
  10. \
  11. \ The external procedure loader follows Pascal calling conventions, i.e.,
  12. \ it will put one longint per parameter and a return address on top of 
  13. \ the A7 stack. Return is made to the code directly following the loaded 
  14. \ external procedure, just as you would expect.
  15. \
  16. \ © 1989 J. Langowski / MacTutor
  17.  
  18. only forth also mac also assembler
  19.  
  20.  \ Code taken with permission from the Mach2 roundtable on GEnie - JL
  21.  \
  22.  \ An example of writing a new looping structure,  ?DO ... NEXT.
  23.  \ Acts like a DO ... LOOP except that the test for loop 
  24.  \ completion is done before the loop body is executed, thus
  25.  \ if the ?DO "limit" is less than or equal to the starting "index"
  26.  \ the loop body will be skipped (remember that a DO ... LOOP will
  27.  \ always execute the loop body at least once, even if the starting
  28.  \ index equals the limit).  Waymen @ PASC  
  29.  
  30.  ASCII ?DO_  CONSTANT ?DOMark
  31.  
  32.  : ?DO  ( limit index -- ) \ compile time  ( -- )
  33.      STATE @
  34.      IF
  35.          $26C526C6 ,    ( MOVE.L  D5,(A3)+
  36.                           MOVE.L  D6,(A3)+ )
  37.          $2C1E2A1E ,    ( MOVE.L  (A6)+,D6
  38.                           MOVE.L  (A6)+,D5 )
  39.          $6000 W,       ( BRA )
  40.       HERE  >R  0 W,    \ space for forward branch offset 
  41.          ?DOMark >R     \ compiler flag
  42.      ELSE
  43.          -1  ABORT" Compile only!"
  44.      THEN ; IMMEDIATE
  45.  
  46.  : NEXT  ( -- )
  47.  \ compile time ( -- )
  48.      STATE @ IF
  49.          R> ?DOMark = IF
  50.              $5286 W,       ( ADDQ.L #1,D6)
  51.              HERE R@  -  R@ W!  \ patch forward branch left by ?DO
  52.              $BA86 W,       ( CMP.L  D6,D5 )
  53.              R>  HERE  -   \ backward branch offset for BGT
  54.              $6E00  W, W,   ( BGT )  
  55.              $2C232A23 ,    ( MOVE.L  -(A3),D6
  56.                               MOVE.L  -(A3),D5 )
  57.          ELSE
  58.              -1 ABORT" Unpaired ?DO"
  59.          THEN
  60.      ELSE
  61.          -1 ABORT" Compile only!"
  62.      THEN ; IMMEDIATE
  63.  
  64. \ ------------------------------------------
  65. \ external procedure linker code starts here
  66. \ ------------------------------------------
  67.  
  68. $20 constant bl
  69. variable subrfile 
  70.  
  71. : pushA6 $2F1E w, ;
  72. : push0 $2F3C w, 0 , ;
  73. : popA6 $2D1F w, ;
  74. : pushret     $41FA0000 , \ LEA 0(PC),A0
  75.             $2F08 w,    \ MOVE.L A0,-(A7)
  76.             here 4-        \ address of PC reference
  77. ;
  78.  
  79. : ExtProc    { | procHdl retAddr -- }
  80.     bl word number? IF ( # params OK )
  81.         0 ?DO pushA6 NEXT
  82.         pushret
  83.         ascii PROC bl word call GetNamedResource
  84.         ?dup IF -> procHdl
  85.             procHdl @ here procHdl call SizeRsrc 
  86.                 dup allot ( procPtr here size )
  87.             cmove \ move code into Forth object space
  88.             here over - swap w! \ resolve LEA reference
  89.         ELSE abort" ExtProc - can't find routine"
  90.         THEN
  91.     ELSE abort" ExtProc - parameter number syntax error"
  92.     THEN
  93. ;
  94.  
  95. : ExtFunc    { | procHdl retAddr -- }
  96.     bl word number? IF ( # params OK )
  97.         push0 \ space for function result
  98.         0 ?DO pushA6 NEXT
  99.         pushret
  100.         ascii FUNC bl word call GetNamedResource
  101.         ?dup IF -> procHdl
  102.             procHdl @ here procHdl call SizeRsrc 
  103.                 dup allot ( procPtr here size )
  104.             cmove \ move code into Forth object space
  105.             here over - swap w! \ resolve LEA reference
  106.             popA6
  107.         ELSE abort" ExtProc - can't find routine"
  108.         THEN
  109.     ELSE abort" ExtProc - parameter number syntax error"
  110.     THEN
  111. ;
  112.  
  113. \ --------------------------------------------------
  114. \ define some calls to external (Fortran) procedures
  115. \ --------------------------------------------------
  116.  
  117. " machsub" call openresfile subrfile !
  118.  
  119. : x2r [ extproc 2 x2r ] ;
  120. : r2x [ extproc 2 r2x ] ;
  121.  
  122. : distance ( p q r | -- )
  123.     [ extproc 3 distance ]
  124. ;
  125.  
  126. variable myarrayH
  127. variable myarraysize
  128.  
  129. : makearray ( arrayhandle arraysize -- )
  130.     [ extproc 2 makearray ]
  131. ;
  132.  
  133. : gaussj ( a n np b m mp ierr -- )
  134.     [ extproc 7 gaussj ]
  135. ;
  136.  
  137. : matmul ( a b c n np m mp l lp -- )
  138.     [ extproc 9 matmul ]
  139. ;
  140.     
  141. subrfile @ call closeresfile
  142.  
  143. \ --------------------------------------------------
  144. \ end of external definitions; testing routines
  145. \ --------------------------------------------------
  146.  
  147. also sane fp
  148. fvariable x 20 vallot
  149. fvariable y 20 vallot
  150. fvariable dist 
  151.  
  152. : f>s { | [ 6 lallot ] x s -- }
  153.     ^ x f! \ store from FP stack into local variable
  154.     ^ x ^ s x2r
  155.     s
  156. ;
  157.  
  158. : s>f { s | [ 6 lallot ] x -- }
  159.     ^ s ^ x r2x
  160.     ^ x f@ \ push local variable to FP stack 
  161. ;
  162.  
  163. : setup.x.y
  164.     1.5 x f!  2.5 x 10 + f!  3.5 x 20 + f!
  165.     3.5 y f! -1.0 y 10 + f!  0.0 y 20 + f!
  166. ;
  167.  
  168. : compute.distance
  169.     x y dist distance
  170.     cr ." The distance between points x and y is "
  171.     dist f@ f. ." units" cr
  172. ;
  173.  
  174. : test.array
  175.     cr ." Setting up 10000 element array..." cr
  176.     10000 myarraySize !
  177.     myarrayH myarraySize makearray
  178.     ." Testing setup: " cr
  179.     10000 0 DO
  180.         ." array(" i . ." ) = " myarrayH @ @ i 4* + @ . cr
  181.     1000 +loop
  182.     myarrayH @ call disposhandle drop
  183. ;
  184.  
  185. 5 constant maxdim 
  186.  
  187. variable n variable n1 
  188. variable m variable m1 
  189. variable ierr 
  190.  
  191. variable a maxdim dup * 4* 4- vallot ( np*np real array )
  192. variable b maxdim 4* 4- vallot ( np el. real vector )
  193. variable c maxdim dup * 4* 4- vallot ( np*np real array )
  194. variable d maxdim 4* 4- vallot ( np el. real vector )
  195.  
  196. : setup.vars 
  197.     maxdim n1 ! 1 m1 ! ;
  198.  
  199. : read.str ( -- addr )
  200.     pad 1+ 80 expect span @ pad c! pad ;
  201.  
  202. : num.inp.err
  203.     ." numeric input error, reenter - "
  204. ;
  205.  
  206. : num.lim.err
  207.     ." number outside limits, reenter - "
  208. ;
  209.  
  210. : read.int 
  211.     begin read.str cr number? not while drop 
  212.     num.inp.err
  213.     repeat
  214. ;
  215.  
  216. : read.real
  217.     begin read.str cr fnumber? not while fdrop 
  218.     num.inp.err
  219.     repeat
  220. ;
  221.  
  222. : read.int.limit { lo hi -- }
  223.     begin
  224.         read.int dup lo > over hi < and
  225.         not while drop
  226.         num.lim.err
  227.     repeat
  228. ;
  229.  
  230. : read.real.limit ( flo fhi -- )
  231.     begin
  232.         fover fover
  233.         read.real
  234.             fswap fover f> fswap fover f< and
  235.             not while fdrop
  236.         num.lim.err
  237.     repeat
  238.     fswap fdrop fswap fdrop
  239. ;
  240.     
  241. : dumpAB { dim | -- }
  242.     dim 0 do
  243.         cr dim 0 do  
  244.             i 5 * j + 4* a + @ s>f f.
  245.         loop
  246.         i 4* b + @ s>f f. 
  247.     loop
  248. ;
  249.     
  250. : dumpC { dim | -- }
  251.     dim 0 do
  252.         cr dim 0 do  
  253.             i 5 * j + 4* c + @ s>f f.
  254.         loop
  255.     loop
  256. ;
  257.  
  258. : gausstest { | dim -- } 
  259.     cr
  260.     setup.vars
  261.     ." Enter problem dimension (min=1,max=10) : " 
  262.         0 n1 @ read.int.limit -> dim
  263.     dim 0 do
  264.         cr ." Enter row # " i . ."  - "
  265.         dim 0 do read.real f>s 
  266.             i 5 * j + 4* a + ! \ store in array a
  267.         loop
  268.         read.real f>s i 4* b + ! \ store right-hand side
  269.     loop
  270.     a c 400 cmove \ copy a to c
  271.  
  272.     cr ." Calling GAUSSJ..."
  273.     dim n ! 1 m !
  274.     a n n1 b m m1 ierr gaussj
  275.     cr ." After GAUSSJ. Components of A,B:"
  276.     dim dumpAB
  277.     cr ." Checking solution. Old A:" dim dumpC
  278.  
  279.     c b d n n1 n n1 m m1 matmul
  280.     cr ." Old B: "
  281.     dim 0 do
  282.         i 4* d + @ s>f f.
  283.     loop
  284.     cr         
  285. ;
  286.  
  287. NEW.WINDOW lineq
  288. " Linear Equations" lineq TITLE
  289. 50 50 300 450 lineq BOUNDS
  290. Document Visible NoCloseBox GrowBox lineq ITEMS
  291.  
  292. 600 5000 terminal gauss
  293.  
  294. : go.gauss activate fp 7 fixed gausstest
  295.     begin ?terminal until
  296.     bye
  297. ;
  298.  
  299. : start
  300.     lineq add
  301.     lineq gauss build
  302.     lineq dup call selectwindow call setport
  303.     gauss go.gauss
  304. ;
  305.  
  306.  
  307.